{-# LANGUAGE ViewPatterns, FlexibleInstances #-}
-----------------------------------------------------------------------------
--
-- Module      :  LLVM.Code.Instructions.Util
-- Copyright   :  Mikhail Belyaev
-- License     :  GPL (Just (Version {versionBranch = [3], versionTags = []}))
--
-- Maintainer  :
-- Stability   :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module LLVM.Code.Instructions.Util where

import LLVM.Util

import LLVM.Code.Shared (ValIndex(..))
import LLVM.Code.Types (getTypeByIndex, TypeTable(..), Type)
import LLVM.Code.Values (vtSize, getValueType, ValueTable(..))
import LLVM.Parser.Record.Record
       (getCode, recordAsHeadlessList, RawRecord(..))
import Data.Maybe (catMaybes, isJust)
data Matcher = MValue | MType | MValueTypePair | MInteger | MMany Matcher deriving (Show,Eq)
data Matched = MdValue ValIndex | MdType Type | MdValueTypePair (ValIndex,Type) | MdInteger Integer |
    MdMany [Matched] deriving (Show,Eq)

match :: TypeTable -> ValueTable -> [Integer] -> [Matcher] -> [Matched]
match tt vt _ [] = []
-- match tt vt (_:_) [] = [] -- error match
match tt vt [] (p:ps) =
    case p of
         MMany _ -> [MdMany []] -- zero or more matches
         _ -> []
match tt vt (i:is) (p:ps) =
    let typeOfV v = vt `getValueType` fromInteger v
        typed t = tt `getTypeByIndex` fromInteger t
    in case p of
            MValue -> (MdValue $ ValIndex i):match tt vt is ps
            MType -> case typed i of
                         Just ty -> (MdType ty):match tt vt is ps
                         Nothing -> []
            MValueTypePair -> case (i:is) of
                                  (typeOfV -> Just ti):rest ->
                                    (MdValueTypePair (ValIndex i, ti)):match tt vt rest ps
                                  (typeOfV -> Nothing):(typed -> Just ti):rest ->
                                    (MdValueTypePair (ValIndex i, ti)):match tt vt rest ps
                                  _ -> []
            MInteger -> (MdInteger i):match tt vt is ps
            MMany patterns -> [MdMany $ match tt vt (i:is) $ repeat patterns]

rrstruct :: TypeTable -> ValueTable -> [Matcher] -> RawRecord -> [Matched]
rrstruct tt vt mrs (recordAsHeadlessList -> (tail -> struct)) = match tt vt struct mrs

matchRRwithCode :: TypeTable -> ValueTable -> [Matcher] -> Integer -> RawRecord -> [Matched]
matchRRwithCode tt vt mrs i rr@(getCode -> Just i') | i' == i = rrstruct tt vt mrs rr
matchRRwithCode _ _ _ _ _ = []

class Unwrappable a where
    unwrap :: Matched -> Maybe a
instance Unwrappable ValIndex where
    unwrap (MdValue v) = Just v
    unwrap _ = Nothing
instance Unwrappable Type where
    unwrap (MdType t) = Just t
    unwrap _ = Nothing
instance Unwrappable Integer where
    unwrap (MdInteger i) = Just i
    unwrap _ = Nothing
instance Unwrappable (ValIndex,Type) where
    unwrap (MdValueTypePair vt) = Just vt
    unwrap _ = Nothing
instance (Unwrappable a) => Unwrappable [a] where
    unwrap (MdMany (map unwrap -> res@(all isJust -> True))) = Just $ catMaybes res
    unwrap _ = Nothing
